Personal Computer World 2006 May/PCWMAY06.iso/Software/Trial/ConceptDraw NetDiagrammer/data1.cab/Samples__Basic/Solutions/OrgChart/drawFunctions.cdb

Text File | 2006-02-08 | 23KB | 432 lines

'Сбор статистики о структуре организации, необходимой для построения эффектной картинки.
Sub GetOrgStatistic()

    Dim i As Integer
    Dim bytDirection As Byte
    Dim dblStepHorizontal As Double
    Dim dblStepVertical As Double
    Dim intMaxAlone As Integer

    ReDim aiMaxBranches(0) As Integer
    ReDim aiDirection(0) As Integer
    aiMaxBranches(0) = 0
    iStatUBound = -1
    bytDirection = conbytAlone
    dblStepHorizontal = condblOneStepX
    dblStepVertical = condblOneStepY
    intMaxAlone = -1

'Рекурсивная процедура. Подсчитывает максимальное количество подчиненных у одного сотрудника
'для каждого уровня служебной иерархии.
    GetBranchStatistic(0, 0)

'Определяет, как будет размещен каждый уровень схемы: по вертикали или горизонтали
    For i = 0 To iStatUBound
        aiDirection(i) = bytDirection
        If intMaxAlone = -1 And aiMaxBranches(i) > 1 Then
             intMaxAlone = i
            bytDirection = conbytHorizontal
        ElseIf intMaxAlone > -1 Then
            If bytDirection = conbytVertical Then
                bytDirection = conbytHorizontal
            Else
                bytDirection = conbytVertical
            End If
        End If
    Next

    intChartHeight = 0
    intChartWidth = 0

'Рекурсивная процедура, определяет размер ветви схемы в документе ConceptDraw.
    SetBranchSize (0, 0, 0, 0)

    intChartHeight = intChartHeight + condblOneStepY
    intChartWidth = intChartWidth + condblOneStepX
End Sub


'========================================================================================================================
'========================================================================================================================

'Рекурсивная процедура. Подсчитывает максимальное количество подчиненных у одного сотрудника
'для каждого уровня служебной иерархии. Помещает это значение в массив aiMaxBranches
'Исследует ветвь древовидной структуры начиная с индекса iPersonStart.
Sub GetBranchStatistic(ByRef iPersonStart As Integer, ByVal intLevel As Integer)
    Dim iNextLevelPerson As Integer
    Dim i As Integer

    aiLevel(iPersonStart) = intLevel
    If iStatUBound < intLevel Then
        iStatUBound = intLevel
'Если размер массивов меньше количества уровней вложенности структуры, размер массивов увеличивается.
        ReDim Preserve aiMaxBranches(intLevel) As Integer
        ReDim Preserve aiDirection(intLevel) As Integer
        aiMaxBranches(intLevel) = asSubordCount(iPersonStart)
    ElseIf  aiMaxBranches(intLevel) < asSubordCount(iPersonStart) Then
'Если у этого сотрудника количество подчиненных больше, чем в просмотренных на этом уровне прежде,
'значение элемента массива aiMaxBranches для этого уровня увеличивается.
        aiMaxBranches(intLevel) = asSubordCount(iPersonStart)
    End If
    For i=0 To asSubordCount(iPersonStart)-1
'Если есть подветви, снова вызывает себя и исследует ветвь дальше.
        GetBranchStatistic(asSubordinates(iPersonStart,i), intLevel + 1)
    Next
End Sub


'========================================================================================================================
'========================================================================================================================

'Рекурсивная процедура, определяет размер ветви схемы в документе ConceptDraw.
'Если ветвь достаточно велика, ее будут размещать на отдельной странице документа.
Sub SetBranchSize(ByRef iPersonStart As Integer, ByVal intLevel As Integer, ByRef dblReturnX As Double, ByRef dblReturnY As Double)
    Dim iNextPerson As Integer
    Dim dNextLevelX As Double
    Dim dNextLevelY As Double
    Dim i As Integer
    dNextLevelX = 0
    dNextLevelY = 0
    dblReturnX = 0
    dblReturnY = 0
    If asSubordCount(iPersonStart) > 0 Then
        For i=0 To asSubordCount(iPersonStart)-1
            iNextPerson = asSubordinates(iPersonStart,i)
'Вызов процедуры рекурсивно для объектов нижнего уровня
            SetBranchSize(iNextPerson, intLevel + 1, dNextLevelX, dNextLevelY)
'Определение размера текущей ветви на основании вычисленной информации о размере
'ветвей нижнего уровня
            Select Case aiDirection(intLevel)
            Case conbytAlone
                If abNewPage(iNextPerson)  Then
                    dblReturnX = dblReturnX + condblOneStepX
                Else
                    dblReturnX = dblReturnX + dNextLevelX
                    If dblReturnY < dNextLevelY Then
                        dblReturnY = dNextLevelY
                    End If
                End If
            Case conbytVertical
                dblReturnX = dblReturnX + dNextLevelX
                If dblReturnY < dNextLevelY Then
                    dblReturnY = dNextLevelY
                End If
            Case conbytHorizontal
                If dblReturnX < dNextLevelX Then
                    dblReturnX = dNextLevelX
                End If
                dblReturnY = dblReturnY + dNextLevelY
            End Select
        Next
            If aiDirection(intLevel) <> conbytAlone Then
                dblReturnX = dblReturnX + condblOneStepX
            End If
        dblReturnY = dblReturnY + condblOneStepY
    Else
        dblReturnX = condblOneStepX
        dblReturnY = condblOneStepY
    End If

    adBranchWidth(iPersonStart) = dblReturnX
    adBranchHeight(iPersonStart) = dblReturnY

    If intChartWidth < dblReturnX Then
        intChartWidth = dblReturnX
    End If
    If intChartHeight < dblReturnY Then
        intChartHeight = dblReturnY
    End If

'Проверяем, не следует ли ветвь, начинающуюся с объекта с индексом iPersonStart,
'рисовать на отдельной странице.
    IsBranchTooLarge(iPersonStart)
End Sub


'========================================================================================================================
'========================================================================================================================

'Проверяем, не следует ли ветвь, начинающуюся с объекта с индексом iPersonStart,
'рисовать на отдельной странице. Если да, информацию об этом заносим в массив abNewPage.
Sub IsBranchTooLarge(ByRef iPersonStart As Integer)
    If Not bAllOnOnePage Then
        If aiLevel(iPersonStart) > 0 Then 'при проверке не выйдем за границы массива aiLevel
'действительно ли эта ветвь является первой неединственной ветвью уровня. Только такая ветвь
'может быть изображена на отдельной странице.
                If aiDirection(aiLevel(iPersonStart)) <> conbytAlone And aiDirection(aiLevel(iPersonStart)-1) = conbytAlone Then
                If adBranchWidth(iPersonStart) > condblMaxX Or adBranchHeight(iPersonStart) > condblMaxY Or adBranchWidth(iPersonStart) * adBranchHeight(iPersonStart) > condblMaxSquare Then
                    abNewPage(iPersonStart) = True
                End If
            End If
        End If
    End If
End Sub

'========================================================================================================================
'========================================================================================================================

'Построение схемы в документе ConceptDraw
Sub DrawChart()
    Dim intReturnPersonLinkNextPages As Integer    'Индекс сотрудника, некоторые подчиненные которого должны рисоваться на отдельной странице
    Dim intFirstPersonOnPage As Integer          'Индекс сотрудника, начинающего ветвь на новой странице.
    Dim lPagesCounter As Long                     'Счетчик количества страниц в документе
    Dim bReturnPersonLinkNextPages As Boolean      'Флаг, указывающий, что некоторые подчиненные сотрудника должны начинать ветвь на отдельной странице
    Dim intLinkToPage As Integer                 'Номер страницы, на которую объект должен иметь гиперлинк
    Dim work_lib As Library                    'Ссылка на открытую библиотеку, содержащую использующиеся объекты.
    Dim lib_master As Master                'Ссылка на Master, содержащий использующийся объект.
    Dim TitleShape As Shape                    'Ссылка на шэйп, изображающий заголовок схемы
    Dim i As Integer                        'Без комментариев.
    Dim activePage As Page                    'Имя переменной говорит само за себя.

    intLinkToPage = 2
     bReturnPersonLinkNextPages = False
    lPagesCounter = thisDoc.PagesNum()

'Настройка параметров документа для более наглядного размещения схемы.
        For i=lPagesCounter To 2 Step -1
        thisDoc.RemovePage(i)
    Next
    lPagesCounter = 1
    activePage=thisDoc.ActivePage
    activePage.RemoveAllShapes
    thisDoc.PageSizeX = intChartWidth
    thisDoc.PageSizeY = intChartHeight
    thisDoc.Scale = 1
    thisDoc.PassThroughGroups = False
    thisDoc.FlowAroundObjects = False
    If (condblOneStepX - condblGroupWidth)/2 > (condblOneStepY - condblGroupHeight)/2 Then
        thisDoc.MinDistToShapes = (condblOneStepY - condblGroupHeight)/2
    Else
        thisDoc.MinDistToShapes = (condblOneStepX - condblGroupWidth)/2
    End If

'Открываю библиотеку ConceptDraw, содержащую использующиеся при построении схемы объекты
    Set work_lib = thisApp.OpenLib("Orgchart.cdl")
    If Null = work_lib Then
        Msgbox("Ne udalos' otkrit' biblioteku Orgchart.cdl")
    Else
'Проверка наличия в библиотеке всех необходимых объектов.
'Если необходимые для построения объекты не найдены, выполнение макроса прекращается.
        Set lib_master = work_lib.MasterByName("Executive")
        If Null = lib_master Then
            Msgbox("Ob'ekt ""Executive"" ne najden v biblioteke")
            Exit Sub
        End If
        Set lib_master = work_lib.MasterByName("Manager")
        If Null = lib_master Then
            Msgbox("Ob'ekt ""Manager"" ne najden v biblioteke")
            Exit Sub
        End If
        Set lib_master = work_lib.MasterByName("Position")
        If Null = lib_master Then
            Msgbox("Ob'ekt ""Position"" ne najden v biblioteke")
            Exit Sub
        End If

'Если известно название компании, оно будет помещено в заголовке документа
        If strOrgName <> "" Then
            Set lib_master = work_lib.MasterByName("Title")
            If Null = lib_master Then
                Msgbox("Ob'ekt ""Title"" ne najden v biblioteke")
            Else
                Set TitleShape = thisDoc.Page(1).DropStamp(lib_master.Shape, Int(intChartWidth / 2), Int(condblOneStepY / 2))
                TitleShape.Shape(TitleShape.ShapesNum()).Text = strOrgName
            End If
        End If


'Рекурсивная процедура. Изображает в документе ветвь структуры, начиная с нулевого индекса.
        DrawBranch(0, 1, -3.1416, -3.1416, Int(adBranchWidth(0) / 2 + condblOneStepX / 2), Int(condblOneStepY / 2), intReturnPersonLinkNextPages, bReturnPersonLinkNextPages, intLinkToPage, work_lib)
         lPagesCounter = lPagesCounter + 1

'Если у объекта некоторые подчиненные должны начать ветвь на отдельной странице, для каждого
'такого подчиненного процедура DrawBranch будет вызвана еще раз.
        If bReturnPersonLinkNextPages Then
            For i=0 To asSubordCount(intReturnPersonLinkNextPages)-1
                intFirstPersonOnPage = asSubordinates(intReturnPersonLinkNextPages, i)
                If abNewPage(intFirstPersonOnPage) Then
                    DrawBranch(intFirstPersonOnPage, lPagesCounter , -3.1416, -3.1416, condblOneStepX, Int(condblOneStepY / 2), intReturnPersonLinkNextPages, bReturnPersonLinkNextPages, 1, work_lib)
                    lPagesCounter = lPagesCounter + 1
                End If
            Next
        End If

    End If

End Sub


'========================================================================================================================
'========================================================================================================================

'Рекурсивная процедура. Изображает в документе ветвь структуры, начиная с объекта с индексом intPerson
Sub DrawBranch(ByRef intPerson As Integer, ByVal lPage As Long, ByVal dblChiefShapeX As Double, ByVal dblChiefShapeY As Double, ByVal dblShapeX As Double, ByVal dblShapeY As Double, ByRef intReturnPersonLinkNextPages As Integer, ByRef bReturnPersonLinkNextPages As Boolean, ByRef intLinkToPage As Integer, ByVal workLib As Library)
'intPerson - индекс сотрудника объект, с которого начинается ветвь
'intPerson - индекс страницы, на которой изображается ветвь
'dblChiefShapeX, dblChiefShapeY - координаты середины родительского объекта, если они равны (-3.1416; -3.1416 ), то текущий объект не буде соединен коннектором с родительским
'dblShapeX, dblShapeY - координаты середины начинающего ветвь объекта
'intReturnPersonLinkNextPages - индекс сотрудника, некоторые подчиненные которого должны рисоваться на отдельной странице
'bReturnPersonLinkNextPages - флаг, указывающий, что некоторые подчиненные объекта должны начинать ветвь на отдельной странице 'intLinkToPage - номер страницы, на которую объект должен иметь гиперлинк
'workLib - ссылка на объект Library, представляющий рабочую библиотеку

    Dim i As Integer
'координаты в документе для следующего шэйпа
    Dim dblNextShapeX As Double
    Dim dblNextShapeY As Double
'Сумма расстояний между уже построенными объектами одного уровня.
    Dim dblSumShapesX As Double
    Dim dblSumShapesY As Double
'Координаты объекта представляющего непосредственного начальника для подчиненного следующего уровня.  'Используется при построении коннекторов. Для объекта самого верхнего уровня окажется равным -1.
    Dim dblForNextLevelChiefX As Double
    Dim dblForNextLevelChiefY As Double
'Индекс подчиненного сотрудника, если у intPerson есть подчиненные
    Dim intNextPerson As Integer
'Ссылка на рабочую страницу
    Dim activePage As Page


    Set activePage = thisDoc.Page(lPage)

    If aiLevel(intPerson) > 0 Then
'В случае необходимости добавляем в документ новую страницу
        If intLinkToPage > 1 And abNewPage(intPerson) Then
            thisDoc.AddPage()
        End If
'Помещаем объект, представляющий одного сотрудника
        DrawPersonData(intPerson, activePage, dblShapeX, dblShapeY, intLinkToPage, workLib)
        If intLinkToPage > 1 And abNewPage(intPerson) Then
            intLinkToPage = intLinkToPage + 1
        End If
'Если на этой странице находится объект, представляющий непосредственного начальника сотрудника,
'эти объекты будут соединены коннектором
        If dblChiefShapeX<>-3.1416 And dblChiefShapeY<>-3.1416 Then
            Select Case aiDirection(aiLevel(intPerson)-1)
            Case conbytAlone
                activePage.DrawSmartConnector(dblChiefShapeX, dblChiefShapeY+condblGroupHeight/2, dblShapeX, dblShapeY-condblGroupHeight/2)
            Case conbytVertical
                activePage.DrawSmartConnector(dblChiefShapeX+condblGroupWidth/2, dblChiefShapeY, dblShapeX, dblShapeY-condblGroupHeight/2)
            Case conbytHorizontal
                activePage.DrawSmartConnector(dblChiefShapeX, dblChiefShapeY+condblGroupHeight/2, dblShapeX-condblGroupWidth/2, dblShapeY)
            End Select
        End If
        dblForNextLevelChiefX = dblShapeX
        dblForNextLevelChiefY = dblShapeY
    Else
        dblForNextLevelChiefX = -3.1416
        dblForNextLevelChiefY = -3.1416
    End If

'Обработка подветвей, описывающих подчиненных данного сотрудника
    If asSubordCount(intPerson) > 0 Then
        dblSumShapesX = condblOneStepX
        dblSumShapesY = condblOneStepY
        For i = 0 To asSubordCount(intPerson)-1
            intNextPerson = asSubordinates(intPerson,i)
            If abNewPage(intPerson) = False Or intLinkToPage = 1 Then
                'Определяем координаты в документе для шэйпов, представляющих подчиненных сотрудника
                Select Case aiDirection(aiLevel(intPerson))
                Case conbytAlone
                    If aiDirection(aiLevel(intPerson)+1) = conbytAlone Then
                        dblNextShapeX = dblShapeX
                        dblNextShapeY = dblShapeY + dblSumShapesY
                    Else
                        dblNextShapeX = dblSumShapesX
                        If abNewPage(intNextPerson) Then
                            dblSumShapesX = dblSumShapesX + condblOneStepX
                            intReturnPersonLinkNextPages = intPerson
                            bReturnPersonLinkNextPages = True
                        Else
                            dblSumShapesX = dblSumShapesX + adBranchWidth(intNextPerson)
                        End If
                        dblNextShapeY = dblShapeY + dblSumShapesY
                    End If
                Case conbytVertical
                    dblNextShapeX = dblShapeX + dblSumShapesX
                    dblSumShapesX = dblSumShapesX + adBranchWidth(intNextPerson)
                    dblNextShapeY = dblShapeY + dblSumShapesY
                Case conbytHorizontal
                    dblNextShapeX = dblShapeX + dblSumShapesX
                    dblNextShapeY = dblShapeY + dblSumShapesY
                    dblSumShapesY = dblSumShapesY + adBranchHeight(intNextPerson)
                End Select
                'Рекурсивный вызов процедуры для построения ветвей схемы для подчиненных сотрудника
                DrawBranch(intNextPerson, lPage, dblForNextLevelChiefX, dblForNextLevelChiefY, dblNextShapeX, dblNextShapeY, intReturnPersonLinkNextPages, bReturnPersonLinkNextPages, intLinkToPage, workLib)
            End If 'если нет перехода на новую страницу
        Next i
    End If
End Sub


'========================================================================================================================
'========================================================================================================================
'Добавление в документ шэйпа, представляющего одного сотрудника
Sub DrawPersonData(ByVal intPerson As Integer, ByRef activePage As Page, ByVal dblShapeX As Double, ByVal dblShapeY As Double, ByVal intLinkToPage As Integer, ByVal workLib As Library)
    Dim libMaster As Master        'Ссылка на Master, содержащий использующийся объект.
    Dim docShape As Shape        'Ссылка на шэйп объекта, помещенного в документ.
    Dim lHyperlinkID As Long    'ID следующего добавленного в документ гиперлика
    Dim strMasterName As String    'Название библиотечного объекта, который будет представлять сотрудника
    Dim textShape As Shape        'Ссылка на шэйп, в который будет помещен текст

    'Выбор объекта, который будет изображать сотрудника
    If aiLevel(intPerson)=1 Then
        strMasterName = "Executive"
    Else
        If abNewPage(intPerson) Then
            strMasterName = "Manager"
        Else
            strMasterName = "Position"
        End If
    End If
    Set libMaster = workLib.MasterByName(strMasterName)
    'Помещение в документ библиотечного объекта
    Set docShape = activePage.DrawStamp(libMaster.Shape, dblShapeX-condblGroupWidth/2, dblShapeY-condblGroupHeight/2, dblShapeX+condblGroupWidth/2, dblShapeY+condblGroupHeight/2)
    'Получение ссылки на шэйп, в который будет помещен текст. Если библиотечный объект
    'являлся группой, текст будет помещен в последний (верхний) child-объект группы.
    If docShape.ShapesNum()>0 Then
        Set textShape = docShape.Shape(docShape.ShapesNum())
    Else
        Set textShape = docShape
    End If

    textShape.Text = asName(intPerson) & Chr(10) & asPost(intPerson)
    If Not IsEmpty(asEMail(intPerson)) Then
        'Привязываю к группе символов, составляющих имя сотрудника, гиперлинк на его email адрес.
        lHyperlinkID = thisDoc.AddHyperlinkToURL("mailto:" & asEMail(intPerson))
        textShape.SetCharHyperlink(1, Len(asName(intPerson)), lHyperlinkID)
    End If
    'При необходимости в шэйпе определяется гиперлинк на другую страницу документа.
    'Описание гиперлинка добавляется в список всех гиперлинков.
    If abNewPage(intPerson) Then
        lHyperlinkID = thisDoc.AddHyperlinkToPageShape(thisDoc.Page(intLinkToPage).ID)
        docShape.Hyperlink = lHyperlinkID
        docShape.DblClick = 4
    End If

    Dim bNewProp As Boolean
    Dim prop As CustomProp
    Dim i As Integer
    Dim j As Integer

    For i = 0 To iCustomCount - 1
        bNewProp = true
        For j = 1 To docShape.CustomPropsNum()
            Set prop = docShape.CustomProp(j)
            If StrComp(prop.Label, asCustom(intPerson, i, 0), 1) = 0 Then
                bNewProp = false
                Exit For
            End If
        Next j
        If bNewProp Then
            Set prop = docShape.AddCustomProp()
        End If
        prop.Label    = asCustom(intPerson, i, 0)
        prop.Prompt        = asCustom(intPerson, i, 0)
        prop.Type        = 0
        prop.Value        = asCustom(intPerson, i, 1)
        prop.Invisible    = FALSE
        prop.Verify        = TRUE
    Next i

End Sub